home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Plurals / eubang.emc < prev    next >
Lisp/Scheme  |  1992-07-15  |  15KB  |  479 lines

  1. #include "mp_arith.h"
  2. #include "mp_type.h"
  3.  
  4. (defmodule eubang (standard0 plural) ()
  5.  
  6.   (setq MasPar-X-Config 16)
  7.   (setq MasPar-Y-Config 32)
  8.  
  9.   (defclass xec ()
  10.     ((context
  11.       initarg context
  12.       reader  cntext)
  13.      (offset
  14.       initarg offset
  15.       reader  offset))
  16.     constructor (allocate-xec context offset)
  17.     predicate xecp)
  18.  
  19.   (defun make-xec (c o)
  20.     (become-strange (allocate-xec c o)))
  21.   
  22.   (defmethod generic-prin ((p xec) str)
  23.     (format str "#x(")
  24.     (mp-print (cntext p) (offset p) str)
  25.     (format str ")")
  26.     p)
  27.   
  28.   (defmethod generic-write ((p xec) str)
  29.     (format str "#x(")
  30.     (mp-print (cntext p) (offset p) str)
  31.     (format str ")")
  32.     p)
  33.  
  34.   (defclass paralation-internal ()
  35.     ((context
  36.       initarg context
  37.       reader context-internal)
  38.      (size
  39.       initarg size
  40.       reader length-internal))
  41.     constructor (allocate-paralation context size)
  42.     predicate paralationp)
  43.  
  44.   (defun make-paralation (size)
  45.     (let* ((height (+ (/ size MasPar-X-Config) 
  46.               (if (zerop (remainder size MasPar-X-Config)) 0 1)))
  47.        (ctxt (mp-make-context (if (= height 1) size MasPar-X-Config)
  48.                   height))
  49.        (ofst (mp-context ctxt))
  50.        (enum (mp-scan-op ctxt (mp-bang ctxt 1) MP_PLUS)))
  51.       (mp-if ctxt (mp-rel-op ctxt enum (mp-bang ctxt size) MP_LE))
  52.       (mp-else ctxt)
  53.       (mp-assign ctxt ofst (mp-bang ctxt '(() ())))
  54.       (mp-fi ctxt)
  55.       (allocate-paralation ctxt size)))
  56.  
  57.   (defclass mp-object ()
  58.     ((paralation
  59.       initarg paralation
  60.       reader paralation)
  61.      (offset
  62.       initarg offset
  63.       reader  offset))
  64.     predicate mp-object-p)
  65.  
  66.   (defun context (mp-o) (context-internal (paralation mp-o)))
  67.  
  68.   (defclass plural (mp-object)
  69.     ()
  70.     constructor (allocate-plural paralation offset)
  71.     predicate pluralp)
  72.  
  73.   (defmethod generic-prin ((p plural) str)
  74.     (format str "#P(")
  75.     (mp-print (context p) (offset p) () () str)
  76.     (format str ")")
  77.     p)
  78.  
  79.   (defmethod generic-write ((p plural) str)
  80.     (format str "#P(")
  81.     (mp-print (context p) (offset p) () () str)
  82.     (format str ")")
  83.     p)
  84.  
  85.   (defun make-plural (n-or-plural)
  86.     (cond 
  87.      ((eq (class-of n-or-plural) integer)
  88.       (let ((new-paralation (make-paralation n-or-plural)))
  89.     (become-strange (allocate-plural new-paralation
  90.                      (mp-make-plural (context-internal 
  91.                               new-paralation))))))
  92.      ((pluralp n-or-plural)
  93.       (become-strange (allocate-plural (paralation n-or-plural) 
  94.                        (mp-make-plural (context 
  95.                             n-or-plural)))))
  96.      (t (error "Aaaeeii, wot dis in make-plural?" clock-tick))))
  97.  
  98.   (defun plural-length (object)
  99.     (if (pluralp object) (length-internal (paralation object))
  100.       (error "Arg1 not a plural" clock-tick)))
  101.  
  102.   (defun plural-ref (plural index)
  103.     (cond
  104.      ((not (pluralp plural)) (error "Arg1 not a plural" clock-tick))
  105.      ((not (eq (class-of index) integer)) 
  106.       (error "Arg2 not an integer" clock-tick))
  107.      (t (mp-ref (context plural) (offset plural) index))))
  108.  
  109.   ((setter setter) plural-ref
  110.      (lambda (plural index value)
  111.      (cond
  112.       ((not (pluralp plural)) (error "Arg1 not a plural" clock-tick))
  113.       ((not (eq (class-of index) integer))
  114.        (error "Arg2 not an integer" clock-tick))
  115.       (t (mp-set (context plural) (offset plural) index value)))
  116.      plural))
  117.  
  118.   (defun if-s-internal (bool consc antec)
  119.     (let ((result (make-plural bool)))
  120.       (if (mp-if (context bool) (offset bool))
  121.     (let ((consc-result (consc)))
  122.       (if (pluralp consc-result)
  123.         (mp-assign (context result) (offset result) 
  124.                (offset consc-result))
  125.         ())) ())
  126.       (if (mp-else (context bool))
  127.     (let ((antec-result (antec)))
  128.       (if (pluralp antec-result)
  129.         (mp-assign (context result) (offset result)
  130.                (offset antec-result))
  131.         ())) ())
  132.       (mp-fi (context bool))
  133.       result))
  134.  
  135.   (defmacro if-s (bool consc antec)
  136.     `(if-s-internal ,bool (lambda () ,consc) (lambda () ,antec)))
  137.  
  138.   (defun list-to-plural (list . plurals)
  139.     (if (or (null plurals) (pluralp (car plurals)))
  140.       (let ((new (if (null plurals) (make-plural (list-length list))
  141.            (make-plural (car plurals)))))
  142.     (labels ((recurse (index list)
  143.            (mp-set (context new) (offset new) index (car list))
  144.            (if (or (zerop index) (null (cdr list))) new
  145.              (recurse (- index 1) (cdr list)))))
  146.       (recurse (- (list-length list) 1) (reverse list))))
  147.       (error "Arg2 not a plural" clock-tick)))
  148.  
  149.   (defun conformantp (arg1 arg2)
  150.     (cond 
  151.      ((not (pluralp arg1)) ())
  152.      ((not (pluralp arg2)) ())
  153.      (t (eq (context arg1) (context arg2)))))
  154.  
  155.   (defun bang (object plural)
  156.     (if (pluralp plural)
  157.       (allocate-plural (paralation plural) (mp-bang (context plural) object))
  158.       (error "Arg2 not a plural" clock-tick)))
  159.  
  160.   (defun auto-bang (arg1 arg2 fn)
  161.     (cond
  162.      ((not (or (pluralp arg1) (pluralp arg2)))
  163.       (error "Neither argument is a plural" clock-tick))
  164.      ((and (pluralp arg1) (pluralp arg2) (conformantp arg1 arg2))
  165.       (allocate-plural (paralation arg1) 
  166.                (fn (context arg1) (offset arg1) (offset arg2))))
  167.      (t (allocate-plural (paralation (if (pluralp arg1) arg1 arg2))
  168.              (if (pluralp arg1)
  169.                  (fn (context arg1) (offset arg1) 
  170.                  (mp-bang (context arg1) arg2))
  171.                (fn (context arg2) (mp-bang (context arg2) arg1)
  172.                    (offset arg2)))))))
  173.  
  174.   (defun abs-s (arg)
  175.     (if (pluralp arg)
  176.     (allocate-plural (paralation arg)
  177.              (mp-un-op (context arg) (offset arg) MP_ABS))
  178.       (error "Arg1 not a plural" clock-tick)))
  179.  
  180.   (defun negate-s (arg)
  181.     (if (pluralp arg)
  182.     (allocate-plural (paralation arg)
  183.              (mp-un-op (context arg) (offset arg) MP_NEGATE))
  184.       (error "Arg1 not a plural" clock-tick)))
  185.  
  186.   (defun delta-s (arg)
  187.     (if (pluralp arg)
  188.     (allocate-plural (paralation arg)
  189.              (mp-un-op (context arg) (offset arg) MP_DELTA))
  190.       (error "Arg1 not a plural" clock-tick)))
  191.  
  192.   (defun sigma-s (arg)
  193.     (if (pluralp arg)
  194.     (allocate-plural (paralation arg)
  195.              (mp-un-op (context arg) (offset arg) MP_SIGMA))
  196.       (error "Arg1 not a plural" clock-tick)))
  197.  
  198.   (defun eq-s (arg1 arg2)
  199.     (if (conformantp arg1 arg2) 
  200.       (allocate-plural (paralation arg1) 
  201.                (mp-eq (context arg1) (offset arg1) (offset arg2)))
  202.       (error "Incompatible arguments" clock-tick)))
  203.  
  204.   (defun cons-s (arg1 arg2)
  205.     (auto-bang arg1 arg2 mp-cons))
  206.  
  207.   (defun car-s (object)
  208.     (if (pluralp object) 
  209.     (allocate-plural (paralation object)
  210.              (mp-car (context object) (offset object)))
  211.       (error "Arg1 is not a plural" clock-tick)))
  212.  
  213.   (defun cdr-s (object)
  214.     (if (pluralp object)
  215.     (allocate-plural (paralation object)
  216.              (mp-cdr (context object) (offset object)))
  217.       (error "Arg1 is not a plural" clock-tick)))
  218.  
  219.   ((setter setter) car-s 
  220.    (lambda (plural value)
  221.      (if (not (pluralp plural)) (error "Arg1 not a plural" clock-tick)
  222.        (auto-bang plural value mp-rplac-a))))
  223.  
  224.   ((setter setter) cdr-s
  225.    (lambda (plural value)
  226.      (if (not (pluralp plural)) (error "Arg1 not a plural" clock-tick)
  227.        (auto-bang plural value mp-rplac-d))))
  228.  
  229.   (defun make-vector-s (length)
  230.     (if (pluralp length) 
  231.       (allocate-plural (paralation length)
  232.                (mp-make-vector (context length) (offset length)))
  233.       (error "Arg1 not a plural" clock-tick)))
  234.  
  235.   (defun vector-length-s (vector)
  236.     (if (pluralp vector)
  237.       (allocate-plural (paralation vector)
  238.                (mp-vector-length (context vector) (offset vector)))
  239.       (error "Arg1 not a plural" clock-tick)))
  240.  
  241.   (defun vector-ref-s (vector index)
  242.     (if (not (pluralp vector)) (error "Arg1 not a plural" clock-tick)
  243.       (auto-bang vector index mp-vector-ref)))
  244.  
  245.   ((setter setter) vector-ref-s
  246.    (lambda (vector index value)
  247.      (if (not (pluralp vector)) (error "Arg1 not a plural" clock-tick)
  248.        (let ((tmp-index (if (pluralp index) index (bang index vector)))
  249.          (tmp-value (if (pluralp value) value (bang value vector))))
  250.      (if (and (eq (context vector) (context tmp-index))
  251.           (eq (context vector) (context tmp-value)))
  252.        (progn
  253.          (mp-vector-set (context vector) (offset vector)
  254.                 (offset tmp-index) (offset tmp-value))
  255.          vector)
  256.        (error "Non-conformant arguments" clock-tick))))))
  257.  
  258.   (defun consp-s (object)
  259.     (if (pluralp object) 
  260.       (allocate-plural (paralation object) 
  261.                (mp-test (context object) (offset object) MP_CONS))
  262.       (error "Arg1 not a plural" clock-tick)))
  263.  
  264. ;  (defun nullp-s (object)
  265. ;    (if (pluralp object) 
  266. ;      (allocate-plural (paralation object)
  267. ;               (mp-test (context object) (offset object) #x7fff))
  268. ;      (error "Arg1 not a plural" clock-tick)))
  269. ;
  270. ; The old hack method doesn't work as nil is now a genuine object on
  271. ; each PE - not just a fancy address
  272.  
  273.   (defun nullp-s (object)
  274.     (if (pluralp object)
  275.       (allocate-plural (paralation object)
  276.                (mp-eq (context object) (offset object) 
  277.                   (mp-bang (context object) ())))
  278.       (error "Arg1 not a plural" clock-tick)))
  279.  
  280.   (defun intp-s (object)
  281.     (if (pluralp object)
  282.       (allocate-plural (paralation object)
  283.                (mp-test (context object) (offset object) INTEGER))
  284.       (error "Arg1 not a plural" clock-tick)))
  285.  
  286.   (defun floatp-s (object)
  287.     (if (pluralp object)
  288.       (allocate-plural (paralation object)
  289.                (mp-test (context object) (offset object) MP_FLOAT))
  290.       (error "Arg1 not a plural" clock-tick)))
  291.  
  292.   (defun vectorp-s (object)
  293.     (if (pluralp object) 
  294.     (allocate-plural (paralation object)
  295.              (mp-test (context object) (offset object) MP_VECTOR))
  296.       (error "Arg1 not a plural" clock-tick)))
  297.  
  298.   (defun scan (p op)
  299.     (allocate-plural (paralation p)
  300.              (mp-scan-op (context p) (offset p)
  301.                  (cond 
  302.                   ((eq op +) MP_PLUS)
  303.                   ((eq op *) MP_TIMES)
  304.                   ((eq op max) MP_MAX)
  305.                   (t MP_MIN)))))
  306.  
  307.   (defun reduce (p op)
  308.     (mp-ref (paralation p)
  309.         (mp-scan-op (context p) (offset p)
  310.             (cond 
  311.              ((eq op +) MP_PLUS)
  312.              ((eq op *) MP_TIMES)
  313.              ((equal op 'max) MP_MAX)
  314.              (t MP_MIN))) (- (field-length p) 1)))
  315.  
  316.   (defmethod binary-plus ((p1 plural) (p2 plural))
  317.     (if (conformantp p1 p2)
  318.       (allocate-plural 
  319.        (paralation p1) (mp-bin-op (context p1) (offset p1) (offset p2) MP_PLUS))
  320.       (error "Non-conformant arguments" clock-tick)))
  321.  
  322.   (defmethod binary-difference ((p1 plural) (p2 plural))
  323.     (if (conformantp p1 p2)
  324.       (allocate-plural 
  325.        (paralation p1) (mp-bin-op (context p1) 
  326.                    (offset p1) (offset p2) MP_DIFFERENCE))
  327.       (error "Non-conformant arguments" clock-tick)))
  328.  
  329.   (defmethod binary-times ((p1 plural) (p2 plural))
  330.     (if (conformantp p1 p2)
  331.       (allocate-plural 
  332.        (paralation p1) (mp-bin-op (context p1) 
  333.                    (offset p1) (offset p2) MP_TIMES))
  334.       (error "Non-conformant arguments" clock-tick)))
  335.  
  336.   (defmethod binary-divide ((p1 plural) (p2 plural))
  337.     (if (conformantp p1 p2)
  338.       (allocate-plural 
  339.        (paralation p1) (mp-bin-op (context p1) 
  340.                    (offset p1) (offset p2) MP_DIVIDE))
  341.       (error "Non-conformant arguments" clock-tick)))
  342.  
  343.   (defmethod binary-gt ((p1 plural) (p2 plural))
  344.     (if (conformantp p1 p2)
  345.       (allocate-plural 
  346.        (paralation p1) (mp-rel-op (context p1) 
  347.                    (offset p1) (offset p2) MP_GT))
  348.       (error "Non-conformant arguments" clock-tick)))
  349.  
  350.   (defmethod binary-lt ((p1 plural) (p2 plural))
  351.     (if (conformantp p1 p2)
  352.       (allocate-plural 
  353.        (paralation p1) (mp-rel-op (context p1) 
  354.                    (offset p1) (offset p2) MP_LT))
  355.       (error "Non-conformant arguments" clock-tick)))
  356.  
  357.   (defun remainder-s (arg1 arg2)
  358.     (cond 
  359.      ((not (pluralp arg1)) (error "Arg1 not a plural" clock-tick))
  360.      ((not (pluralp arg2)) (error "Arg2 not a plural" clock-tick))
  361.      ((not (conformantp arg1 arg2)) 
  362.       (error "Non-conformant arguments" clock-tick))
  363.      (t (allocate-plural (paralation arg1) 
  364.              (mp-bin-op (context arg1) (offset arg1) 
  365.                     (offset arg2) MP_REMAINDER)))))
  366.  
  367.   (defun and-s (arg1 arg2)
  368.     (auto-bang arg1 arg2 mp-and))
  369.  
  370.   (defun or-s (arg1 arg2)
  371.     (auto-bang arg1 arg2 mp-or))
  372.  
  373.   (defclass mapping (mp-object)
  374.     ()
  375.     constructor (allocate-mapping paralation offset)
  376.     predicate mappingp)
  377.  
  378.   (defun match (to from)
  379.     (if (and (pluralp from) (pluralp to))
  380.       (allocate-mapping (paralation to) (mp-match (context to) (offset to)
  381.                            (context from) (offset from)))
  382.       (error "Both args should be plurals" clock-tick)))
  383.  
  384.   (defun move (data map with default)
  385.     (cond
  386.      ((not (pluralp data)) (error "Arg1 msut be a plural" clock-tick))
  387.      ((not (mappingp map)) (error "Arg2 must be a mapping" clock-tick))
  388.      (t (let ((moved (allocate-plural (paralation map) 
  389.                       (mp-move (context data) (offset data)
  390.                            (context map) (offset map)))))
  391.       (labels ((recurse (list-s cdr-list-s)
  392.              (if-s-internal cdr-list-s 
  393.                (lambda () (with (car-s list-s) 
  394.                  (recurse cdr-list-s (cdr-s cdr-list-s))))
  395.                (lambda () (car-s list-s)))))
  396.         (if-s-internal moved (lambda () (recurse moved (cdr-s moved)))
  397.           (lambda () (bang default moved))))))))
  398.  
  399. ; Modification to mp-move - plural for result has to be preallocated
  400.  
  401.   (defun move (data map with default)
  402.     (cond
  403.      ((not (pluralp data)) (error "Arg1 msut be a plural" clock-tick))
  404.      ((not (mappingp map)) (error "Arg2 must be a mapping" clock-tick))
  405.      (t (let ((moved (allocate-plural (paralation map) 
  406.                       (mp-make-plural (context map)))))
  407.       (mp-move (context data) (offset data)
  408.            (context map) (offset map) (offset moved))
  409.       (labels ((recurse (list-s cdr-list-s)
  410.              (if-s-internal cdr-list-s 
  411.                (lambda () (with (car-s list-s) 
  412.                  (recurse cdr-list-s (cdr-s cdr-list-s))))
  413.                (lambda () (car-s list-s)))))
  414.         (if-s-internal moved (lambda () (recurse moved (cdr-s moved)))
  415.           (lambda () (bang default moved))))))))
  416.  
  417.   (defun ll-move (data map)
  418.     (cond 
  419.      ((not (pluralp data)) (error "Arg1 must be a plural" clock-tick))
  420.      ((not (mapping  map)) (error "Arg2 must be a mapping" clock-tick))
  421.      (t (allocate-plurak (paralation map)
  422.              (mp-move (context data) (offset data) 
  423.                   (context map)  (ofset map))))))
  424.  
  425.   (defun look-at-mapping (map)
  426.     (if (mappingp map)
  427.       (allocate-plural (paralation map) (offset map))
  428.       (error "Arg1 should be a map" clock-tick)))
  429.   (defun visualise (p)
  430.     (if (pluralp p) (progn 
  431.                (mp-x-stat (context p) (offset p))
  432.                p)
  433.       (error "Arg1 not a plural")))
  434.  
  435. (export match move make-plural plural-length bang plural-ref 
  436.     list-to-plural eq-s if-s if-s-internal cons-s car-s cdr-s 
  437.     and-s or-s visualise
  438.     abs-s negate-s sigma-s delta-s
  439.     make-vector-s vector-length-s vector-ref-s
  440.     consp-s nullp-s intp-s floatp-s vectorp-s
  441.     ll-move mp-gc)
  442.  
  443. )
  444.  
  445.  
  446. ; This function probably needs adding, this is its hacked from CM-Lisp
  447. ; form
  448.  
  449. ;   (defun put (x at in)
  450. ;     (cond 
  451. ;      ((not (xecp in)) (error "Destination (arg 2) is not a xec" clock-tick))
  452. ;      ((not (conformantp x at)) 
  453. ;       (error "Values and indexes not conformant" clock-tick))
  454. ;      (t (let ((ctxt-x  (context x))
  455. ;           (ofst-at (offset at))
  456. ;           (ctxt-in (context in)))
  457. ;       (allocate-xec 
  458. ;        ctxt-in
  459. ;        (cm-put ctxt-x (offset x)
  460. ;            (mp-bin-op ctxt-x ofst-at
  461. ;                   (mp-bin-op ctxt-x ofst-at
  462. ;                      (mp-bang ctxt-x (cm-start in))))))))))
  463.  
  464.  
  465.  
  466.  
  467.  
  468.  
  469.  
  470.  
  471.  
  472.  
  473.  
  474.  
  475.  
  476.  
  477.  
  478.  
  479.